;;; Guile-GCC --- Guile extension to GCC.               -*- coding: utf-8 -*-
;;; Copyright (C) 2012 Ludovic Courtès
;;;
;;; This file is part of Guile-GCC.
;;;
;;; Guile-GCC is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Guile-GCC is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Guile-GCC.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gcc)
  #:use-module (system foreign)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (rnrs bytevectors)
  #:export (%plugin-arguments
            tree?
            null-tree?
            %unknown-location
            %builtins-location
            location?
            location-file
            location-line
            location-column
            location-system-header?
            expand-location

            ;; the embedded DSL
            tree

            ;; tree accessors
            tree-code
            tree-type
            debug-tree
            c-lex-with-flags
            decl-name
            decl-source-location
            identifier-string
            string-constant-value
            type-fields

            pass?
            make-pass
            pass-name
            pass-type
            pass-handler

            pass-position
            register-pass
            register-callback
            register-c-pragma
            get-identifier
            lookup-name
            current-function-decl
            size-in-bytes
            int-size-in-bytes
            built-in-decl
            add-statement
            build-int-cst
            build-string-literal
            build-call-expr
            build-component-ref
            build-component-ref*
            build-addr

            error-at
            warning-at
            inform
            permissive-error))


;;;
;;; Naming conventions.
;;;

(define (schemify-name str)
  "Turn STR, a C variable or function name, into a more Schemey form--i.e.,
one with dashed instead of underscores, etc."
  (string->symbol
   (let ((str (string-downcase str)))
     (string-map (lambda (chr)
                   (if (eq? chr #\_)
                       #\-
                       chr))
                 (cond ((string-suffix? "_p" str)
                        (string-append (substring str 0
                                                  (- (string-length str) 2))
                                       "?"))
                       ((string-suffix? "_x" str)
                        (string-append (substring str 0
                                                  (- (string-length str) 2))
                                       "!"))
                       ((string-prefix? "set_" str)
                        (string-append "set-"
                                       (substring str 4 (string-length str))
                                       "!"))
                       (else str))))))


(define c-macro-name?
  (let ((cs (char-set-union char-set:upper-case
                            char-set:digit
                            (char-set #\_))))
    (lambda (name)
      "Return true when NAME is possibly a C macro name."
      (string-every cs name))))


;;;
;;; Passes.
;;;

(define-wrapped-pointer-type <pass> pass?
  wrap-pass unwrap-pass
  (lambda (pass port)
    (format port "#<gcc pass ~s ~x (~x)>"
            (pass-name pass)
            (object-address pass) (object-address (unwrap-pass pass)))))

(define (make-pass name type handler)
  "Return a new compiler pass of type TYPE, named NAME, and whose execution
is handled by HANDLER, a thunk that returns an unsigned int of TODOs."
  (wrap-pass
   (%make-pass (string->pointer name) type
               (procedure->pointer unsigned-int handler '()))))

(define-syntax define-pass-accessor
  (syntax-rules ()
    ((_ name subr)
     (define (name pass)
       (subr (unwrap-pass pass))))
    ((_ name subr wrap-result)
     (define (name pass)
       (wrap-result (subr (unwrap-pass pass)))))))

(define-pass-accessor pass-type %pass-type)
(define-pass-accessor pass-name %pass-name)
(define-pass-accessor pass-handler %pass-execute
  (lambda (pointer)
    (pointer->procedure void pointer '())))


;;;
;;; Tree.
;;;

(define-wrapped-pointer-type <tree> tree?
  wrap-tree unwrap-tree
  (lambda (t p)
    (format p "#<gcc tree ~x (~x) ~a>"
            (object-address t) (object-address (unwrap-tree t))
            (TREE_CODE (unwrap-tree t)))))

;; For consumption by (gcc cgraph) and other modules.
(define %wrap-tree wrap-tree)
(define %unwrap-tree unwrap-tree)

(define (null-tree? t)
  "Return #t when T is a null tree."
  (null-pointer? (unwrap-tree t)))

(define %null-tree
  (wrap-tree %null-pointer))

(define (false-or-wrap-tree p)
  (if (null-pointer? p)
      #f
      (wrap-tree p)))

(define (dereference-pointer-to-int ptr)
  "Return the `int' value pointed to by PTR."
  (let ((bv (pointer->bytevector ptr (sizeof int))))
    (bytevector-uint-ref bv 0 (native-endianness) (sizeof int))))

(define (tree-list->foreign-array lst)
  "Return a pointer to a foreign array of trees containing the trees in LST."
  (let* ((count  (length lst))
         (array  (make-bytevector (* count (sizeof '*))))
         (ftrees (map unwrap-tree lst)))
    (fold (lambda (ftree index)
            (bytevector-uint-set! array index (pointer-address ftree)
                                  (native-endianness)
                                  (sizeof '*))
            (+ index (sizeof '*)))
          0
          ftrees)
    (bytevector->pointer array)))

(define (tree-list->alist t)
  "Turn T, a TREE_LIST, into a list of value/purpose pairs."
  (unfold null-tree?
          (lambda (t)
            (cons (tree-value t) (tree-purpose t)))
          tree-chain
          t))

(define (tree->list t)
  "Return a list made from T.  If T is a TREE_LIST, use `tree-list->alist'."
  (if (= TREE_LIST (tree-code t))
      (tree-list->alist t)
      (unfold (negate tree?) identity tree-chain t)))

(module-for-each (lambda (sym var)
                   (let ((name (symbol->string sym)))
                     (if (c-macro-name? name)
                         (let ((val (variable-ref var)))
                           (cond ((string-suffix? "_P" name)
                                  ;; Type predicate.  Define a type-safe
                                  ;; wrapper around the unsafe C subr---e.g.,
                                  ;; `decl?' for `DECL_P'.
                                  (let ((sym (schemify-name name)))
                                    (module-define! (current-module) sym
                                                    (lambda (obj)
                                                      (val (unwrap-tree obj))))
                                    (module-export! (current-module)
                                                    (list sym))))
                                 ((string-prefix? "SET_" name)
                                  ;; Setter.  Do something similar---e.g.,
                                  ;; `SET_TREE_SIDE_EFFECTS' to
                                  ;; `set-tree-side-effects!'.
                                  (let ((sym (schemify-name name)))
                                    (module-define! (current-module) sym
                                                    (lambda (obj new-val)
                                                      (val (unwrap-tree obj)
                                                           new-val)))
                                    (module-export! (current-module)
                                                    (list sym))))
                                 ((integer? val)
                                  ;; Constant such as `PLUGIN_PRAGMAS'.
                                  (module-export! (current-module)
                                                  (list sym))))))))
                 (current-module))

(define-syntax define-tree-accessor
  (syntax-rules (type)
    "Define a tree accessor NAME that wraps raw accessor C-NAME."
    ((_ name c-name wrap (type code))
     (define (name obj)
       (if (= code (tree-code obj))
           (wrap (c-name (unwrap-tree obj)))
           (throw 'wrong-type-arg "wrong type argument"))))
    ((_ name c-name wrap (pred ...))
     (define (name obj)
       (if (and (pred obj) ...)
           (wrap (c-name (unwrap-tree obj)))
           (throw 'wrong-type-arg "wrong type argument"))))
    ((_ name c-name wrap)
     (define-tree-accessor name c-name wrap ()))
    ((_ name c-name (pred ...))
     (define-tree-accessor name c-name identity (pred ...)))
    ((_ name c-name)
     (define-tree-accessor name c-name identity ()))))

(define-tree-accessor tree-code TREE_CODE)
(define-tree-accessor tree-type TREE_TYPE wrap-tree)
(define-tree-accessor decl-name DECL_NAME wrap-tree (decl?))
(define-tree-accessor decl-source-location DECL_SOURCE_LOCATION
  identity (decl?))
(define-tree-accessor identifier-string IDENTIFIER_POINTER
  pointer->string (type IDENTIFIER_NODE))
(define-tree-accessor string-constant-value TREE_STRING_POINTER
  pointer->string (type STRING_CST))
(define-tree-accessor type-fields TYPE_FIELDS
  (compose tree->list wrap-tree) (record-or-union-type?))
(define-tree-accessor tree-value TREE_VALUE (type TREE_LIST))
(define-tree-accessor tree-purpose TREE_PURPOSE (type TREE_LIST))
(define-tree-accessor tree-chain TREE_CHAIN false-or-wrap-tree)



;;;
;;; Source code location.
;;;

(define location_t int)
(define %unknown-location 0)
(define %builtins-location -1)

(define %expanded-location-struct
  ;; The `expanded_location' struct.
  `(*                                          ; const char *file
    ,int                                       ; int line
    ,int                                       ; int column
    ,int8                                      ; bool sysp
    ))


;;;
;;; Programming interface.
;;;

(define-syntax-rule (cc1-symbol name)
  "Return a `cc1' symbol, taken from the current DSO."
  (dynamic-func name (dynamic-link)))

(define keep
  (let ((kept '()))
    (lambda (obj)
      "Prevent OBJ from ever being collected; return OBJ.  Use with care."
      (set! kept (cons obj kept))
      obj)))

(define %struct-register-pass-info
  ;; The `register_pass_info' structure.
  `(*     ;; New pass to register.

    *     ;; Name of the reference pass for hooking up the new pass.

    ,int  ;; Insert the pass at the specified instance number of the reference
          ;; pass. Do it for every instance if it is 0.

    ,int  ;; How to insert the new pass.
    ))

(define-syntax pass-position
  (lambda (stx)
    (syntax-case stx (after before replace)
      ((_ after)   #'PASS_POS_INSERT_AFTER)
      ((_ before)  #'PASS_POS_INSERT_BEFORE)
      ((_ replace) #'PASS_POS_REPLACE)
      (x
       (syntax-violation "pass-position" "unsupported pass position value"
                         #'x)))))

(define* register-pass
  (let ((f (pointer->procedure void (cc1-symbol "register_callback")
                               `(* ,int * *))))
    (lambda* (plugin pass ref-pass-name
                     #:optional (where (pass-position after))
                     #:key (ref-pass-instance-number 0))
      "Insert PASS for PLUGIN next to the pass called REF-PASS-NAME, with
WHERE being one of the values returned by `pass-position'.
REF-PASS-INSTANCE-NUMBER specifies the instance of REF-PASS-NAME that is
targeted; 0 means all the instances of REF-PASS-NAME."
      (let ((info (make-c-struct %struct-register-pass-info
                                 (list (unwrap-pass (keep pass))
                                       (string->pointer ref-pass-name)
                                       ref-pass-instance-number
                                       where))))
        (f (keep (string->pointer plugin)) PLUGIN_PASS_MANAGER_SETUP
           %null-pointer info)))))

(define register-callback
  (let ((f (pointer->procedure void (cc1-symbol "register_callback")
                               `(* ,int * *))))
    (lambda (name event proc)
      "Register PROC as a callback for EVENT, for plug-in NAME."
      (f (keep (string->pointer name)) event
         (keep (procedure->pointer void
                                   (lambda (gcc-data user-data)
                                     (proc))
                                   '(* *)))
         %null-pointer))))

(define register-c-pragma                         ; c-family front-ends
  (let ((f (delay (pointer->procedure void (cc1-symbol "c_register_pragma")
                                      '(* * *)))))
    (lambda (name-space name handler)
      "Register the pragma NAME under NAME-SPACE, with procedure HANDLER."
      (let ((f (force f)))
        (f (keep (string->pointer name-space))
           (keep (string->pointer name))
           (keep (procedure->pointer void
                                     (lambda (cpp)
                                       (handler
                                        ((@@ (gcc cpp) %wrap-cpp-reader) cpp)))
                                     '(*))))))))

(define-record-type <location>
  (make-location file line column sys?)
  location?
  (file   location-file)
  (line   location-line)
  (column location-column)
  (sys?   location-system-header?))

(define expand-location
  (let ((f (pointer->procedure %expanded-location-struct
                               (cc1-symbol "expand_location")
                               `(,location_t))))
    (lambda (loc)
      "Return a location object from LOC, an integer as returned by
`decl-source-location' & co."
      (match (parse-c-struct (f loc) %expanded-location-struct)
        ((file line column sys?)
         (make-location (pointer->string file) line column
                        (not (= 0 sys?))))))))

(define c-lex-with-flags                          ; c-family front-ends
  (let ((f (delay (pointer->procedure int (cc1-symbol "c_lex_with_flags")
                                      `(* * * ,int)))))
    (lambda* (#:key (translate-strings? #t) (join-strings? #t))
      "Read one token with the current C-family parser and return its
corresponding `tree' object, its CPP token type, and its location."

      ;; Constants from <c-pragma.h>.
      (define C_LEX_STRING_NO_TRANSLATE 1)
      (define C_LEX_STRING_NO_JOIN 2)

      (let* ((&value (bytevector->pointer
                      (make-bytevector (sizeof '*))))
             (&loc   (bytevector->pointer
                      (make-bytevector (sizeof location_t))))
             (flags  (logior (if translate-strings?
                                 0
                                 C_LEX_STRING_NO_TRANSLATE)
                             (if join-strings?
                                 0
                                 C_LEX_STRING_NO_JOIN)))
             (type   ((force f) &value &loc
                      %null-pointer               ; cpp_flags
                      flags))
             (value  (dereference-pointer &value))
             (loc    (dereference-pointer-to-int &loc)))
        (if (null-pointer? value)
            (values #f type loc)
            (values (wrap-tree value) type loc))))))

(define debug-tree
  (let ((f (pointer->procedure void (cc1-symbol "debug_tree") '(*))))
    (lambda (t)
      "Print T to the standard output; return T."
      (f (unwrap-tree t))
      t)))

(define current-function-decl
  (let ((ptr (cc1-symbol "current_function_decl")))
    (lambda ()
      "Return the current function declaration."
      (wrap-tree (dereference-pointer ptr)))))

(define get-identifier
  (let ((f (pointer->procedure '* (cc1-symbol "get_identifier") '(*))))
    (lambda (name)
      "Return an identifier for NAME."
      (wrap-tree (f (string->pointer name))))))

(define lookup-name                               ; c-family front-ends
  (let ((f (delay (pointer->procedure '* (cc1-symbol "lookup_name") '(*)))))
    (lambda (identifier)
      "Return the declaration associated with IDENTIFIER, or #f."
      (let ((p ((force f) (unwrap-tree identifier))))
        (if (null-pointer? p)
            #f
            (wrap-tree p))))))

(define size-in-bytes
  (let ((f (pointer->procedure '* (cc1-symbol "size_in_bytes") '(*))))
    (lambda (type)
      "Return the size in bytes of TYPE as a tree."
      (wrap-tree (f (unwrap-tree type))))))

(define int-size-in-bytes
  (let ((f (pointer->procedure long               ; HOST_WIDE_INT
                               (cc1-symbol "int_size_in_bytes") '(*))))
    (lambda (type)
      "Return the size in bytes of TYPE as an integer."
      (f (unwrap-tree type)))))

(define built-in-decl
  (let ((ptr (cc1-symbol "built_in_decls")))
    (lambda (built-in)
      "Return the built-in declaration of BUILT-IN, an integer (one of the
`BUILT_IN_' constants."
      (let ((ptr (make-pointer (+ (* built-in (sizeof '*))
                                  (pointer-address ptr)))))
        (wrap-tree (dereference-pointer ptr))))))

(define add-statement
  (let ((f (delay (pointer->procedure void (cc1-symbol "add_stmt") '(*)))))
    (lambda (stmt)
      "Add STMT to the current function body.  Works only for C-family
front-ends."
      ((force f) (unwrap-tree stmt)))))

(define build
  (let* ((mem-stat-decl `(* ,int *))              ; FILE, LINE, FUNCTION
         (mem-stat-info (let ((loc (current-source-location)))
                          (list (string->pointer
                                 (or (assoc-ref loc 'filename) "gcc.scm"))
                                (or (assoc-ref loc 'line) 0)
                                (string->pointer "build"))))
         (b0            (pointer->procedure '* (cc1-symbol "build0_stat")
                                            `(,int * ,@mem-stat-decl)))
         (b1            (pointer->procedure '* (cc1-symbol "build1_stat")
                                            `(,int * * ,@mem-stat-decl)))
         (b2            (pointer->procedure '* (cc1-symbol "build2_stat")
                                            `(,int * * * ,@mem-stat-decl)))
         (b3            (pointer->procedure '* (cc1-symbol "build3_stat")
                                            `(,int * * * * ,@mem-stat-decl)))
         (b4            (pointer->procedure '* (cc1-symbol "build4_stat")
                                            `(,int * * * * *
                                                   ,@mem-stat-decl))))
    (case-lambda
      ((code type)
       (wrap-tree (apply b0 code (unwrap-tree type) mem-stat-info)))
      ((code type x)
       (wrap-tree (apply b1 code (unwrap-tree type) (unwrap-tree x)
                         mem-stat-info)))
      ((code type x y)
       (wrap-tree (apply b2 code (unwrap-tree type) (unwrap-tree x)
                         (unwrap-tree y) mem-stat-info)))
      ((code type x y z)
       (wrap-tree (apply b3 code (unwrap-tree type) (unwrap-tree x)
                         (unwrap-tree y) (unwrap-tree z) mem-stat-info)))
      ((code type a b c d)
       (wrap-tree (apply b4 code (unwrap-tree type) (unwrap-tree a)
                         (unwrap-tree b) (unwrap-tree c) (unwrap-tree d)
                         mem-stat-info))))))

(define build-int-cst
  (let ((f (pointer->procedure '* (cc1-symbol "build_int_cst")
                               `(* ,long))))      ; 2nd arg is HOST_WIDE_INT
    (lambda (type value)
      "Return an integer constant of TYPE equal to VALUE.  When TYPE is #f,
default to `integer-type-node'."
      (wrap-tree (f (if type (unwrap-tree type) %null-pointer) value)))))

(define build-string-literal
  (let ((f (pointer->procedure '* (cc1-symbol "build_string_literal")
                               `(,int *))))
    (lambda (s)
      "Return a string literal for S."
      (wrap-tree (f (+ 1 (string-length s)) (string->pointer s))))))

(define build-call-expr
  (let ((f (pointer->procedure '* (cc1-symbol "build_call_expr_loc_array")
                               `(,location_t * ,int *))))
    (lambda (loc fndecl args)
      "Return a call to FNDECL with ARGS."
      (wrap-tree (f loc (unwrap-tree fndecl) (length args)
                    (tree-list->foreign-array args))))))

(define build-component-ref                       ; c-family front-ends
  (let ((f (delay (pointer->procedure '* (cc1-symbol "build_component_ref")
                                      `(,location_t * *)))))
    (lambda (loc datum field-name)
      "Return a component reference for FIELD-NAME, an identifier, in
RECORD, which is a union or a structure."
      (wrap-tree ((force f) loc (unwrap-tree datum)
                            (unwrap-tree field-name))))))

(define (build-component-ref* datum field-decl)
  "Return the COMPONENT_REF for FIELD-DECL in DATUM."
  (and (record-or-union-type? (tree-type datum))
       (= (tree-code field-decl) FIELD_DECL) ; FIXME: Raise an error instead.
       (build COMPONENT_REF (tree-type field-decl) datum field-decl
              %null-tree)))

(define build-addr
  (let ((f (pointer->procedure '* (cc1-symbol "build_addr")
                               '(* *))))
    (lambda* (obj #:optional (context (current-function-decl)))
      "Return the address of OBJ within function CONTEXT."
      (wrap-tree (f (unwrap-tree obj)
                    (if (not context)
                        %null-pointer
                        (unwrap-tree context)))))))


;;;
;;; Tree embedded domain-specific language (EDSL).
;;;

(define-syntax expand-literal
  (lambda (stx)
    ;; When STX is a literal string or integer, expand it to a tree literal
    ;; building expression.
    (syntax-case stx ()
      ((_ str)
       (string? (syntax->datum #'str))
       #'(build-string-literal str))
      ((_ int)
       (integer? (syntax->datum #'int))
       #'(build-int-cst #f int))
      ((_ x)
       ;; Can't determine the type of X statically.
       #'(let ((t x))
           (cond ((string? t)
                  (build-string-literal t))
                 ((integer? t)
                  (build-int-cst #f t))
                 (else t)))))))

(define-syntax tree
  (lambda (stx)
    ;; Transform the given syntax form into a tree-building expression.  This
    ;; macro implements the tree EDSL.
    ;; TODO: Add `let', `set!', `if', `=', etc.
    (syntax-case stx (built-in & dot)
      ((_ loc (built-in name))
       #'(built-in-decl name))
      ((_ loc (& x))
       #'(build-addr (tree loc x)))
      ((_ loc (obj dot slot))
       (string? (syntax->datum #'slot))
       #'(build-component-ref loc (tree loc obj) slot))
      ((_ loc (obj dot field-decl))
       #'(build-component-ref* (tree loc obj) field-decl))
      ((_ loc (proc arg ...))
       #'(build-call-expr loc (tree loc proc)
                          (list (tree loc arg) ...)))
      ((_ loc x)
       #'(expand-literal x)))))


;;;
;;; Diagnostics.
;;;

(define-syntax define-diagnostic-procedure
  (lambda (stx)
    (syntax-case stx ()
      ((_ name c-name)
       (with-syntax ((private-name
                      (datum->syntax #'name
                                     (symbol-append '%private-
                                                    (syntax->datum #'name)))))
         #'(begin
             (define private-name
               (let ((f (pointer->procedure void (cc1-symbol c-name)
                                            `(,location_t * *)))
                     (s (string->pointer "%s")))
                 (lambda (loc str)
                   (f loc s (string->pointer str)))))
             (define-syntax name
               (syntax-rules ()
                 ((_ loc fmt . args)
                  (private-name loc (format #f fmt . args)))))))))))

(define-diagnostic-procedure error-at "error_at")
(define-diagnostic-procedure warning-at "warning_at")
(define-diagnostic-procedure inform "inform")
(define-diagnostic-procedure permissive-error "permerror")


;;;
;;; Load user code specified with the `-fplugin-arg-guile-load' flag.
;;;

(for-each load-from-path
          (filter-map (match-lambda
                       (("load" . file)
                        file)
                       (_ #f))
                      %plugin-arguments))
